Olympic history 2

Dataset

Link do danych

Link 2

Context

This is a historical dataset on the modern Olympic Games, including all the Games from Athens 1896 to Rio 2016. I scraped this data from www.sports-reference.com in May 2018. The R code I used to scrape and wrangle the data is on GitHub. I recommend checking my kernel before starting your own analysis.

Note that the Winter and Summer Games were held in the same year up until 1992. After that, they staggered them such that Winter Games occur on a four year cycle starting with 1994, then Summer in 1996, then Winter in 1998, and so on. A common mistake people make when analyzing this data is to assume that the Summer and Winter Games have always been staggered.

Content

The file athlete_events.csv contains 271116 rows and 15 columns. Each row corresponds to an individual athlete competing in an individual Olympic event (athlete-events). The columns are:

1. ID - Unique number for each athlete
2. Name - Athlete’s name
3. Sex - M or F . Age - Integer
4. Height - In centimeters
5. Weight - In kilograms
6. Team - Team name
7. NOC - National Olympic Committee 3-letter code
8. Games - Year and season
9. Year - Integer
10. Season - Summer or Winter
11. City - Host city
12. Sport - Sport
13. Event - Event
14. Medal - Gold, Silver, Bronze, or NA

Acknowledgements

The Olympic data on www.sports-reference.com is the result of an incredible amount of research by a group of Olympic history enthusiasts and self-proclaimed ‘statistorians’. Check out their blog for more information. All I did was consolidated their decades of work into a convenient format for data analysis. Inspiration

This dataset provides an opportunity to ask questions about how the Olympics have evolved over time, including questions about the participation and performance of women, different nations, and different sports and events.

library(dplyr)
library(tidyr)
library(ggplot2)
library(knitr)
library(kableExtra) # do tabel w stylu bootstrap 5

Eksploracja danych

d1 <- read.csv('athlete_events.csv')
dim(d1)

[1] 271116     15

head(d1[1:3,1:7])

ID	Name	Sex	Age	Height	Weight	Team
1	A Dijiang	M	24	180	80	China
2	A Lamusi	M	23	170	60	China
3	Gunnar Nielsen Aaby	M	24	NA	NA	Denmark

head(d1[1:3,8:15])

NOC	Games	Year	Season	City	Sport	Event	Medal
CHN	1992 Summer	1992	Summer	Barcelona	Basketball	Basketball Men’s Basketball	NA
CHN	2012 Summer	2012	Summer	London	Judo	Judo Men’s Extra-Lightweight	NA
DEN	1920 Summer	1920	Summer	Antwerpen	Football	Football Men’s Football	NA

options(width = 150)
quantitive_cols <- c("ID", "Age", "Height", "Weight", "Year")
summary(d1[quantitive_cols])

       ID              Age            Height          Weight           Year     
 Min.   :     1   Min.   :10.00   Min.   :127.0   Min.   : 25.0   Min.   :1896  
 1st Qu.: 34643   1st Qu.:21.00   1st Qu.:168.0   1st Qu.: 60.0   1st Qu.:1960  
 Median : 68205   Median :24.00   Median :175.0   Median : 70.0   Median :1988  
 Mean   : 68249   Mean   :25.56   Mean   :175.3   Mean   : 70.7   Mean   :1978  
 3rd Qu.:102097   3rd Qu.:28.00   3rd Qu.:183.0   3rd Qu.: 79.0   3rd Qu.:2002  
 Max.   :135571   Max.   :97.00   Max.   :226.0   Max.   :214.0   Max.   :2016  
                  NA's   :9474    NA's   :60171   NA's   :62875                 

# names(d1)
categorical_cols <- setdiff(names(d1), quantitive_cols)
categorical_cols

 [1] "Name"   "Sex"    "Team"   "NOC"    "Games"  "Season" "City"   "Sport"  "Event"  "Medal" 

categ_df_list <- list()

for(i in categorical_cols) {
  count <- length(na.omit(d1[[i]]))
  unique <- length(unique(na.omit(d1[[i]])))
  nan_perc <- sum(is.na(d1[[i]]))
  
  top_three_sorted <- sort(table(d1[[i]]), decreasing = TRUE)[1:3]
  top_three_names <- names(top_three_sorted)
  top_three_counts <- as.vector(top_three_sorted)
  
  names <- c('category', "Count", "Unique", "% NA", top_three_names[1], top_three_names[2], top_three_names[3])
  values <- c(i, count, unique, as.character(round(nan_perc / 271116, 2)), top_three_counts[1], top_three_counts[2], top_three_counts[3])
  categ_df <- setNames(as.data.frame(t(values)), names)
  
  categ_df_list[[i]] <- categ_df
}

names <- rep('|', 7)
values <- rep(' ', 7)
empty_df <- t(setNames(as.data.frame(t(values)), names))

# kod tylko dla pierwszego wiersza

knitr::kable(
  list(t(categ_df_list[[1]]), empty_df, t(categ_df_list[[2]]), empty_df, t(categ_df_list[[3]]), empty_df, t(categ_df_list[[4]])),
  caption = 'Widok na kolumny kategoryczne z trzema najczęściej występującymi wartościami',
  booktabs = TRUE, valign = 't'
)

Widok na kolumny kategoryczne z trzema najczęściej występującymi wartościami

category Name Count 271116 Unique 134732 % NA 0 Robert Tait McKenzie 58 Heikki Ilmari Savolainen 39 Joseph “Josy” Stoffel 38

| | | | | | |

category Sex Count 271116 Unique 2 % NA 0 M 196594 F 74522 NA NA

| | | | | | |

category Team Count 271116 Unique 1184 % NA 0 United States 17847 France 11988 Great Britain 11404

| | | | | | |

category NOC Count 271116 Unique 230 % NA 0 USA 18853 FRA 12758 GBR 12256

category Games Count 271116 Unique 51 % NA 0 2000 Summer 13821 1996 Summer 13780 2016 Summer 13688

| | | | | | |

category Season Count 271116 Unique 2 % NA 0 Summer 222552 Winter 48564 NA NA

| | | | | | |

category City Count 271116 Unique 42 % NA 0 London 22426 Athina 15556 Sydney 13821

| | | | | | |

category Sport Count 271116 Unique 66 % NA 0 Athletics 38624 Gymnastics 26707 Swimming 23195

category Event Count 271116 Unique 765 % NA 0 Football Men’s Football 5733 Ice Hockey Men’s Ice Hockey 4762 Hockey Men’s Hockey 3958

| | | | | | |

category Medal Count 39783 Unique 3 % NA 0.85 Gold 13372 Bronze 13295 Silver 13116

Brakujące dane

Rzeczywiście brakujące dane występują tylko w kolumnach wieku, wzrostu i wagi. Z oczywistych powodów brakujące dane w kontekście medali nie oznaczają nieistniejących danych, tylko nie zajęcie miejsca na podium. Jednak ciekawym aspektem medali jest ich nierówna ilość. Przyczynami mogą być:

1. Remisy - wg. załączonego artykułu różnica między ilością medali wynosi 10 i 12, nie ponad 200
2. Liczba zawodników równa 2 lub 1 - być może prawdopodobne w przypadku wczesnych olimpiad i niszowych zawodów, jednak gdyby ta zależność była istotna, najmniej byłoby medali brązowych, a nie srebrnych. Może to być spowodowane też np. nieodpowiednimi warunkami pogodowymi i dany zawodnik nie podjął się uczestnictwa
3. Dyskwalifikacje, przekazanie medali, usunięcie medali najczęściej ze względu na doping - wg. artykułu w latach 1905-2022 odebrano 159 medali, ale tylko 9 nie zostało przekazanych innym zawodnikom, więc nadal to nie pokrywa rozrzutu w naszych danych
4. Powyższe, ale w kontekście zawodów zespołowych, w takich przypadkach dysproporcja mogła się bardziej zwiększyć
5. Anulowanie zawodów czy różnice wynikające ze zmian historycznych np. zmian zasad, sposobów oceniania etc. - rzeczy, których bez intensywnego zgłębiania historii olimpiad raczej się nie wykryje.

Wizualizacja wybranych aspektów danych

# rozmiary czcionek
s <- 10
m <- 12
l <- 15

games_count <- d1 %>%
  group_by(Games, Year, Season) %>%
  summarise(Count = n()) %>%
  arrange(desc(Count)) %>% 
  ungroup()

`summarise()` has grouped output by 'Games', 'Year'. You can override using the `.groups` argument.

games_count

# A tibble: 51 × 4
   Games        Year Season Count
   <chr>       <int> <chr>  <int>
 1 2000 Summer  2000 Summer 13821
 2 1996 Summer  1996 Summer 13780
 3 2016 Summer  2016 Summer 13688
 4 2008 Summer  2008 Summer 13602
 5 2004 Summer  2004 Summer 13443
 6 1992 Summer  1992 Summer 12977
 7 2012 Summer  2012 Summer 12920
 8 1988 Summer  1988 Summer 12037
 9 1972 Summer  1972 Summer 10304
10 1984 Summer  1984 Summer  9454
# ℹ 41 more rows

# sortowanie po latach
games_count$Games <- factor(games_count$Games, levels = games_count$Games[order(games_count$Year)]) 

d <- ggplot(games_count, aes(x = Games, y = Count, fill = Games)) +
  geom_bar(stat = "identity") +
  labs(x = "Games", y = "Count", title = "Count of Games by Year") +
  theme_minimal() + theme_light() + 
  theme_minimal() + theme_light() +
  geom_bar(stat = "identity") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  labs(y = "Ilość zawodników", x = "Rok i sezon igrzysk", title = "Ilość zawodników w Igrzyskach Olimpijskich") +
  theme(text = element_text(family = "Courier New")) +
  theme(axis.title.x = element_text(size=m),
        axis.title.y = element_text(size=m),
        axis.text.x = element_text(size=s),
        axis.text.y = element_text(size=s),
        plot.title = element_text(colour="Black", size=l, family="Courier New")) + 
  theme(legend.position = "none") + 
  scale_y_continuous(breaks = seq(0, max(games_count$Count), by = 1000))  # Ilość linii pomocniczych na Y
# d

d1_noNA <- d1[!(is.na(d1$Medal)), ]

medal_counts <- d1_noNA %>%
  group_by(NOC, Medal) %>%
  summarise(Count = n()) %>%
  ungroup()

`summarise()` has grouped output by 'NOC'. You can override using the `.groups` argument.

medal_counts

# A tibble: 362 × 3
   NOC   Medal  Count
   <chr> <chr>  <int>
 1 AFG   Bronze     2
 2 AHO   Silver     1
 3 ALG   Bronze     8
 4 ALG   Gold       5
 5 ALG   Silver     4
 6 ANZ   Bronze     5
 7 ANZ   Gold      20
 8 ANZ   Silver     4
 9 ARG   Bronze    91
10 ARG   Gold      91
# ℹ 352 more rows

medal_counts <- medal_counts[order(medal_counts$Count, decreasing=TRUE), ]
medal_counts_p <- medal_counts %>%
    pivot_wider(
      names_from=Medal,
      values_from=Count
    )
medal_counts_p$Total <- medal_counts_p$Gold + medal_counts_p$Silver + medal_counts_p$Bronze

medal_counts_p <- medal_counts_p[order(medal_counts_p$Total, decreasing=T),]
head(medal_counts_p, 3)

# A tibble: 3 × 5
  NOC    Gold Silver Bronze Total
  <chr> <int>  <int>  <int> <int>
1 USA    2638   1641   1358  5637
2 URS    1082    732    689  2503
3 GER     745    674    746  2165

dim(medal_counts_p)

[1] 149   5

top_countries <- medal_counts_p %>%
  arrange(desc(Total)) %>%
  head(25) %>%
  pull(NOC)
top_countries

 [1] "USA" "URS" "GER" "GBR" "FRA" "ITA" "SWE" "CAN" "AUS" "RUS" "HUN" "NED" "NOR" "GDR" "CHN" "JPN" "FIN" "SUI" "ROU" "KOR" "DEN" "FRG" "POL" "ESP"
[25] "TCH"

top_medal_counts <- medal_counts %>%
  filter(NOC %in% top_countries)
head(top_medal_counts)

# A tibble: 6 × 3
  NOC   Medal  Count
  <chr> <chr>  <int>
1 USA   Gold    2638
2 USA   Silver  1641
3 USA   Bronze  1358
4 URS   Gold    1082
5 GER   Bronze   746
6 GER   Gold     745

# Poprawienie sortowania państw
top_medal_counts$NOC <- factor(top_medal_counts$NOC, levels = top_countries)
head(top_medal_counts)

# A tibble: 6 × 3
  NOC   Medal  Count
  <fct> <chr>  <int>
1 USA   Gold    2638
2 USA   Silver  1641
3 USA   Bronze  1358
4 URS   Gold    1082
5 GER   Bronze   746
6 GER   Gold     745

# Sortowanie bloków na słupkach - brąz, srebro, złoto
top_medal_counts$Medal <- factor(top_medal_counts$Medal, levels = c("Bronze", "Silver", "Gold"))
top_medal_counts

# A tibble: 75 × 3
   NOC   Medal  Count
   <fct> <fct>  <int>
 1 USA   Gold    2638
 2 USA   Silver  1641
 3 USA   Bronze  1358
 4 URS   Gold    1082
 5 GER   Bronze   746
 6 GER   Gold     745
 7 GBR   Silver   739
 8 URS   Silver   732
 9 URS   Bronze   689
10 GBR   Gold     678
# ℹ 65 more rows

medale_kolor <- c("Bronze"="#9D755d", "Silver"="#E2E2E2", "Gold"="#FECB52")
medale_nazwy <- c("Bronze"="Brąz", "Silver"="Srebro", "Gold"="Złoto")

e <- ggplot(top_medal_counts, aes(fill = Medal, y = Count, x = NOC)) +
  theme_minimal() + theme_light() +
  geom_bar(stat = "identity") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  labs(fill = "Medal:", y = "Ilość medali", x = "Kraj", title = "Top 25 Państw w olimpiadach") +
  theme(text = element_text(family = "Courier New")) + 
  theme(axis.title.x = element_text(size=m),
        axis.title.y = element_text(size=m),
        axis.text.x = element_text(size=s),
        axis.text.y = element_text(size=s),
        legend.title = element_text(size=s),
        legend.text = element_text(size=s),
        legend.justification = c(0,0.5),
        plot.title = element_text(colour="Black", size=l, family="Courier New")) +
  scale_fill_manual(values=medale_kolor, labels=medale_nazwy)

Zestaw danych zawiera nieistniejące już kraje, takie jak Związek Radziecki czy Jugosławia.

NOC_count <- d1 %>%
  group_by(NOC) %>%
  summarise(Count = n())
head(NOC_count)

# A tibble: 6 × 2
  NOC   Count
  <chr> <int>
1 AFG     126
2 AHO      79
3 ALB      70
4 ALG     551
5 AND     169
6 ANG     267

medal_counts_p_ratio <- inner_join(medal_counts_p, NOC_count, by = "NOC")
medal_counts_p_ratio$Ratio <- round(medal_counts_p_ratio$Total / medal_counts_p_ratio$Count, 2)
medal_counts_p_ratio <- medal_counts_p_ratio[order(medal_counts_p_ratio$Ratio, decreasing=TRUE), ]
medal_counts_p_ratio <- head(medal_counts_p_ratio, 25)
head(medal_counts_p_ratio)

# A tibble: 6 × 7
  NOC    Gold Silver Bronze Total Count Ratio
  <chr> <int>  <int>  <int> <int> <int> <dbl>
1 URS    1082    732    689  2503  5685  0.44
2 GDR     397    327    281  1005  2645  0.38
3 ANZ      20      4      5    29    86  0.34
4 EUN     127     71     81   279   864  0.32
5 USA    2638   1641   1358  5637 18853  0.3 
6 RUS     390    367    408  1165  5143  0.23

write.csv(medal_counts_p_ratio, "medal_counts_p_ratio.csv")

medal_counts_p_ratio <- medal_counts_p_ratio %>% arrange(desc(medal_counts_p_ratio)) # sortowanie

max_total <- max(medal_counts_p_ratio$Total) # maksymalna wartość do limitu


f <- ggplot(medal_counts_p_ratio, aes(x = reorder(NOC, -Ratio))) +
  geom_bar(aes(y = Total), stat = "identity", fill = "#00CC96") + 
  geom_line(aes(y = Ratio * max_total, group = 1), color = "#EF553B", size = 0.7) +
  geom_text(aes(y = Ratio * max_total, label = Ratio), 
            vjust = -1.1, color = "black", size=2.3, family="Courier New", fontface="bold") +
  
  scale_y_continuous( # do ustawienia 1.0 na prawej Y do max lewej Y
    name = "Ilośc medali",
    sec.axis = sec_axis(~ . / max_total, name = "Stosunek zdobytych medali do ilości zawodników")
  ) +
  
  labs(x="Kraj", title = "Ilość zdobytych medali i stosuenk do ilości zawodników") +
  theme_minimal() + theme_light() +
  theme(
    text = element_text(family = "Courier New"),
    axis.title.x = element_text(size=m),
    axis.title.y = element_text(size=m),
    axis.title.y.right = element_text(color = "#873021"),
    axis.text.y.right = element_text(size=s, color = "#873021"),
    plot.title = element_text(colour="Black", size=l, family="Courier New")
  )
#f

Mniej oczywiste kody państw / reprezentacji:

• GDR - NRD
• ANZ - Australazja - Australia i Nowa Zeladnia
• EUN - Unified Team - reprezentacja byłych krajów ze Związku Radzieckiego podczas zimowej olimpiady w 1992 we Francji
• SCG - Serbia i Montenegro - na tej samej olimpiadzie co wyżej

Jak widać, na tym wykresie pojawiły się reprezentacje państw z bardzo niewielką ilością zawodników, stąd trochę niewyważona statystyka. Niemniej ciekawe jest, że państwa bloku sowieckiego mają najlepszy stosunek medali do ilości zawodników.

max_Poland_age <- max(d1[d1$Team == "Poland",]$Age, na.rm = TRUE)
cat(max_Poland_age)

71

season_colors <- c("Winter" = "#636EFA", "Summer" = "#FFA15A")
season_names <- c("Winter" = "Zima", "Summer" = "Lato")

b <- ggplot(data=d1[d1$Team == "Poland",], aes(x=Sex, y=Height, color=Season)) + 
  geom_boxplot(alpha=0.9) +
  ylim(140, 230) +
  xlab("Płeć") +
  ylab("Wzrost [cm]") +
  ggtitle("Wzrost polskich zawodników") +
  theme(text = element_text(family = "Courier New")) + 
  theme(axis.title.x = element_text(size=m),
        axis.title.y = element_text(size=m),
        axis.text.x = element_text(size=s),
        axis.text.y = element_text(size=s),
        legend.title = element_text(size=s),
        legend.text = element_text(size=s),
        legend.justification = c(0,0.5),
        plot.title = element_text(colour="Black", size=l, family="Courier New")) +
  scale_color_manual(values=season_colors, labels=season_names) +
  scale_x_discrete(labels=c("F" = "Kobiety", "M" = "Mężczyźni")) +
  labs(color='Sezon')
#b

Ten sam wykres, ale dla amerykańskich zawodników. Te dwa wykresy dają pewną wskazówkę dla korelacji wzrostu ze zwycięstwami, w zależności od sezonu - sportowcy z USA wygrywają przeważającą ilość medali i konsekwentnie w przypadku sezonu letniego są wyżsi, a zimowego - niżsi. Wyjątek stanowią kobiety uczestniczące w olimpiadzie zimowej. Kolejno zostaną sprawdzone korelacje.

Korelacje

Sprawdzenie korelacji odbędzie się na dwóch kolumnach. Zostaną wykorzystane atrybuty takie jak wiek, waga, wzrost, reprezentacja.

-Won - one-hot encoding - 0 lub 1, czy zawodnik zdobył złoty medal,
-Score- ordinal encoding - złoto:3, srebro:2, brąz:1, brak medalu:0

encode_gold <- function(medal) {
  if (is.na(medal)) {return(0)}
  else if (medal == "Gold") {return(1)} 
  else {{return(0)}}
}
cat(c(encode_gold('Gold'), encode_gold('Silver'), encode_gold(NA)))

1 0 0

encode_score <- function(medal) {
  if (is.na(medal)) {return(0)}
  else if (medal == "Gold") {return(3)} 
  else if (medal == "Silver") {return(2)} 
  else {{return(1)}}
}
cat(c(encode_gold('Gold'), encode_gold('Silver'), encode_gold(NA)))

1 0 0

d1 <- d1 %>%
  mutate(Won = sapply(Medal, encode_gold)) %>%
  mutate(Score = sapply(Medal, encode_score))

head(d1[68:69, 13:17]) %>%
  kbl() %>%
  kable_material(c("striped", "hover"))

	Sport	Event	Medal	Won	Score
68	Alpine Skiing	Alpine Skiing Men’s Combined	Silver	0	2
69	Alpine Skiing	Alpine Skiing Men’s Downhill	NA	0	0

quantitive_cols <- c("Age", "Height", "Weight", "Year", "Won", "Score")

round(cor(na.omit(d1[quantitive_cols])),  digits = 2)

        Age Height Weight  Year   Won Score
Age    1.00   0.14   0.21  0.09  0.01  0.02
Height 0.14   1.00   0.80  0.05  0.06  0.09
Weight 0.21   0.80   1.00  0.02  0.05  0.08
Year   0.09   0.05   0.02  1.00 -0.03 -0.04
Won    0.01   0.06   0.05 -0.03  1.00  0.80
Score  0.02   0.09   0.08 -0.04  0.80  1.00

Jak widać dla wszystkich danych korelacje są praktycznie nieznaczące, poza oczywistą korelacją waga-wzrost. Ponieważ w rzeczywistości mamy “filtr” odrzucający sportowców niespełniających wymagania uczestnictwa na najwyższym poziomie, większość sportowców na olimpiadzie będzie wykazywała te same cechy np. w koszykówce przeważająca większość zawodników będzie wysoka. Dlatego poprzez pętlę zostaną wyszukane dziedziny o istotnych korelacjach i jednocześnie różnorodnych cechach zawodników.

options(width = 110)
unique(d1$Sport)

 [1] "Basketball"                "Judo"                      "Football"                 
 [4] "Tug-Of-War"                "Speed Skating"             "Cross Country Skiing"     
 [7] "Athletics"                 "Ice Hockey"                "Swimming"                 
[10] "Badminton"                 "Sailing"                   "Biathlon"                 
[13] "Gymnastics"                "Art Competitions"          "Alpine Skiing"            
[16] "Handball"                  "Weightlifting"             "Wrestling"                
[19] "Luge"                      "Water Polo"                "Hockey"                   
[22] "Rowing"                    "Bobsleigh"                 "Fencing"                  
[25] "Equestrianism"             "Shooting"                  "Boxing"                   
[28] "Taekwondo"                 "Cycling"                   "Diving"                   
[31] "Canoeing"                  "Tennis"                    "Modern Pentathlon"        
[34] "Figure Skating"            "Golf"                      "Softball"                 
[37] "Archery"                   "Volleyball"                "Synchronized Swimming"    
[40] "Table Tennis"              "Nordic Combined"           "Baseball"                 
[43] "Rhythmic Gymnastics"       "Freestyle Skiing"          "Rugby Sevens"             
[46] "Trampolining"              "Beach Volleyball"          "Triathlon"                
[49] "Ski Jumping"               "Curling"                   "Snowboarding"             
[52] "Rugby"                     "Short Track Speed Skating" "Skeleton"                 
[55] "Lacrosse"                  "Polo"                      "Cricket"                  
[58] "Racquets"                  "Motorboating"              "Military Ski Patrol"      
[61] "Croquet"                   "Jeu De Paume"              "Roque"                    
[64] "Alpinism"                  "Basque Pelota"             "Aeronautics"              

head(d1[d1$Sport=="Basketball",][quantitive_cols],3)

    Age Height Weight Year Won Score
1    24    180     80 1992   0     0
168  19    185     72 2008   0     0
251  31     NA     NA 1952   0     0

cors <- round(cor(na.omit(d1[d1$Sport=="Basketball",][quantitive_cols])),
              digits = 2 
)

cors

         Age Height Weight  Year   Won Score
Age     1.00  -0.02   0.04  0.31  0.01 -0.01
Height -0.02   1.00   0.87  0.09  0.05  0.06
Weight  0.04   0.87   1.00  0.09  0.05  0.05
Year    0.31   0.09   0.09  1.00 -0.07 -0.05
Won     0.01   0.05   0.05 -0.07  1.00  0.80
Score  -0.01   0.06   0.05 -0.05  0.80  1.00

Pętla pozytywnych korelacji w dziedzinach olimpijskich (filtr powyżej 0.2) względem złota:

for(i in unique(d1$Sport)) {
  subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,5] # korelacja dla Win
  if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
      if (max(win_cor) >= 0.2) {
        print(i)
        print(win_cor)
    }
  }
}

[1] "Softball"
   Age Height Weight 
 -0.01   0.14   0.22 

Pętla negatywnych korelacji w dziedzinach olimpijskich (filtr poniżej -0.2) względem złota:

for(i in unique(d1$Sport)) {
  subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,5] # korelacja dla Win
  if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
      if (max(win_cor) <= -0.2) {
        print(i)
        print(win_cor)
    }
  }
}

[1] "Tug-Of-War"
   Age Height Weight 
 -0.22  -0.21  -0.44 

Okazuje się że w ogólnych dziedzinach (Sport) sportowych korelacje zwycięstw do są również bardzo nieznaczne. Jedyne warte wspomnienia to softball oraz przeciąganie liny, dziedziny, które pojawiły się na olimpiadach tylko pięć razy. Poniżej sprawdzenie dla poszczególnych dyscyplin (Event).

Pętla pozytywnych korelacji w dziedzinach olimpijskich (filtr powyżej 0.2 i 50 zawodników) względem złota:

for(i in unique(d1$Event)) {
  subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,5] # korelacja dla Win
  if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
      if (max(win_cor) > 0.25) { # korelacja +- 0.25 
        if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
          cat(nrow(subset), 'zawodników, ', i, '\n')
          print(win_cor)
        }
    }
  }
}

76 zawodników,  Taekwondo Men's Featherweight 
   Age Height Weight 
 -0.11   0.12   0.41 
82 zawodników,  Cross Country Skiing Men's 10/10 kilometres Pursuit 
   Age Height Weight 
  0.10   0.26   0.25 
136 zawodników,  Cross Country Skiing Men's Team Sprint 
   Age Height Weight 
  0.05   0.13   0.26 
82 zawodników,  Shooting Women's Skeet 
   Age Height Weight 
  0.08   0.12   0.33 
60 zawodników,  Cycling Women's Individual Pursuit, 3,000 metres 
   Age Height Weight 
  0.01   0.23   0.36 
74 zawodników,  Swimming Men's 10 kilometres Open Water 
   Age Height Weight 
  0.02   0.34   0.26 
51 zawodników,  Shooting Women's Double Trap 
   Age Height Weight 
 -0.18   0.03   0.42 
59 zawodników,  Freestyle Skiing Women's Ski Cross 
   Age Height Weight 
 -0.06   0.31   0.16 

Pętla negatywnych korelacji w dyscyplinach olimpijskich (filtr poniżej -0.25 i powyżej i 50 zawodników) względem złota:

for(i in unique(d1$Event)) {
  subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,5] # korelacja dla Win
  if (!anyNA(cors[1:3,5])) { # czy nie zawiera NA
      if (min(win_cor) < -0.25) { # korelacja +- 0.25 
        if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
          cat(nrow(subset), 'zawodników, ', i, '\n')
          print(win_cor)
        }
    }
  }
}

71 zawodników,  Taekwondo Women's Heavyweight 
   Age Height Weight 
 -0.28   0.24   0.02 
80 zawodników,  Diving Women's Synchronized Springboard 
   Age Height Weight 
  0.00   0.03  -0.34 
80 zawodników,  Diving Men's Synchronized Platform 
   Age Height Weight 
 -0.19  -0.44  -0.46 
80 zawodników,  Diving Women's Synchronized Platform 
   Age Height Weight 
 -0.35  -0.19  -0.42 
67 zawodników,  Wrestling Women's Middleweight, Freestyle 
   Age Height Weight 
 -0.14  -0.06  -0.27 

Z tych danych można podkreślić następujące zależności:

• niemała pozytywna korelacja do wagi w przypadku Taekwondo w męskiej kategorii piórkowej - masa w sztukach walki jest bardzo istotna!
• z drugiej strony w przypadku wrestlingu w kobiecej kategorii średniej mamy odwrotną zależność 🤷‍♀️
• duża ujemna korelacja wagi w synchronizowanych skokach do wody i to w trzech różnych kategoriach

Poniżej to samo, ale sprawdzenie dla nowej kolumny Score, a nie Win.

Pętla pozytywnych korelacji w dziedzinach olimpijskich (filtr powyżej 0.2) względem ustalonej punktacji Score:

for(i in unique(d1$Sport)) {
  subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,6] # korelacja dla Win
  if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
      if (max(win_cor) >= 0.2) {
        print(i)
        print(win_cor)
    }
  }
}

[1] "Softball"
   Age Height Weight 
  0.06   0.18   0.24 
[1] "Synchronized Swimming"
   Age Height Weight 
  0.23   0.09   0.08 
[1] "Rhythmic Gymnastics"
   Age Height Weight 
  0.00   0.24   0.05 

Pętla negatywnych korelacji w dziedzinach olimpijskich (filtr poniżej -0.2) względem ustalonej punktacji Score:

for(i in unique(d1$Sport)) {
  subset <- na.omit(d1[d1$Sport==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,6] # korelacja dla Score
  if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
      if (max(win_cor) <= -0.2) {
        print(i)
        print(win_cor)
    }
  }
}

[1] "Tug-Of-War"
   Age Height Weight 
 -0.24  -0.25  -0.52 

Pętla negatywnych korelacji w dyscyplinach olimpijskich (filtr poniżej -0.25 i powyżej i 50 zawodników) względem Score:

for(i in unique(d1$Event)) {
  subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,6] # korelacja dla Win
  if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
      if (max(win_cor) > 0.25) { # korelacja +- 0.25 
        if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
          cat(nrow(subset), 'zawodników, ', i, '\n')
          print(win_cor)
        }
    }
  }
}

63 zawodników,  Weightlifting Women's Super-Heavyweight 
   Age Height Weight 
 -0.11   0.28   0.21 
77 zawodników,  Taekwondo Men's Flyweight 
   Age Height Weight 
 -0.06   0.28   0.32 
76 zawodników,  Taekwondo Men's Featherweight 
   Age Height Weight 
 -0.08   0.11   0.33 
78 zawodników,  Taekwondo Men's Welterweight 
   Age Height Weight 
 -0.06   0.26   0.14 
365 zawodników,  Rhythmic Gymnastics Women's Group 
   Age Height Weight 
  0.02   0.29   0.08 
437 zawodników,  Figure Skating Mixed Pairs 
   Age Height Weight 
  0.27   0.05   0.03 
206 zawodników,  Rowing Women's Lightweight Double Sculls 
   Age Height Weight 
  0.17   0.27   0.13 
54 zawodników,  Gymnastics Women's Team Portable Apparatus 
   Age Height Weight 
  0.36   0.11   0.19 
95 zawodników,  Cross Country Skiing Women's 3 x 5 kilometres Relay 
   Age Height Weight 
  0.32  -0.11  -0.20 
754 zawodników,  Ice Hockey Women's Ice Hockey 
   Age Height Weight 
  0.13   0.23   0.31 
206 zawodników,  Curling Women's Curling 
   Age Height Weight 
  0.26   0.03   0.17 
95 zawodników,  Cycling Men's Madison 
   Age Height Weight 
  0.32  -0.14  -0.08 
71 zawodników,  Cross Country Skiing Women's 5/5 kilometres Pursuit 
   Age Height Weight 
  0.04   0.15   0.28 
82 zawodników,  Cross Country Skiing Men's 10/10 kilometres Pursuit 
   Age Height Weight 
  0.08   0.27   0.25 
82 zawodników,  Shooting Women's Skeet 
   Age Height Weight 
  0.08   0.14   0.35 
69 zawodników,  Snowboarding Women's Boardercross 
   Age Height Weight 
  0.10   0.26   0.09 
74 zawodników,  Swimming Men's 10 kilometres Open Water 
   Age Height Weight 
  0.11   0.34   0.20 
51 zawodników,  Shooting Women's Double Trap 
   Age Height Weight 
 -0.25   0.08   0.39 
59 zawodników,  Freestyle Skiing Women's Ski Cross 
   Age Height Weight 
  0.01   0.28   0.14 
50 zawodników,  Canoeing Men's Canadian Singles, 200 metres 
   Age Height Weight 
  0.20   0.22   0.40 

Pętla negatywnych korelacji w dyscyplinach olimpijskich (filtr poniżej -0.25 i powyżej i 50 zawodników) względem Score:

for(i in unique(d1$Event)) {
  subset <- na.omit(d1[d1$Event==i,][quantitive_cols])
  cors <- round(cor(subset), digits = 2)
  win_cor <- cors[1:3,6] # korelacja dla Win
  if (!anyNA(cors[1:3,6])) { # czy nie zawiera NA
      if (min(win_cor) < -0.25) { # korelacja +- 0.25 
        if (nrow(subset) >= 50) { # czy ilość zawodników jest sensowna
          cat(nrow(subset), 'zawodników, ', i, '\n')
          print(win_cor)
        }
    }
  }
}

80 zawodników,  Diving Women's Synchronized Springboard 
   Age Height Weight 
  0.14   0.03  -0.35 
56 zawodników,  Cross Country Skiing Men's 18 kilometres 
   Age Height Weight 
 -0.04  -0.17  -0.31 
80 zawodników,  Diving Men's Synchronized Platform 
   Age Height Weight 
 -0.24  -0.32  -0.38 
60 zawodników,  Fencing Women's Sabre, Team 
   Age Height Weight 
 -0.27   0.10   0.06 
80 zawodników,  Diving Women's Synchronized Platform 
   Age Height Weight 
 -0.32  -0.26  -0.37 
129 zawodników,  Short Track Speed Skating Women's 1,500 metres 
   Age Height Weight 
 -0.33   0.02   0.10 

Wyniki przedstawiają się podobnie, w niektórych kategoriach Win ma mniejsze wartości korelacji niż Score, w innych większe. W przypadku pętli dla Score znaleziono więcej kategorii, w których korelacje były znaczące. Ostatnią rzeczą wartą zaznaczenia jest fakt, że wzrost ma najniższe korelacje spośród wyżej wymienionych dyscyplin. Oznacza to, że różnice we wzroście są najmniejsze lub najrzadsze, lub różnica we wzroście nie jest istotna w większości dyscyplin.

Analiza tylko na medalach z Shiny

Pakiet Shiny umożliwia tworzenie interaktywnych aplikacji i raportów, które w prosty sposób można udostępniać i otwierać np. w zwykłej przeglądarce internetowej.

Niestety, w celu uproszczenia udostępniania ninejszej strony, funkcjonalność pakietu Shiny zostanie przedstawiona w formie gifu. Prawdziwa aplikacja pod tym linkiem.

only_medals <- d1[!is.na(d1$Medal), ] # odfiltrowanie wierszy bez medali

ile_medali <- nrow(only_medals)

only_medals <- only_medals[only_medals$NOC %in% top_countries, ]

ile_po_filtrze <- nrow(only_medals)

cat("Ilość wierszy z medalami: ", ile_po_filtrze, ', ', round(ile_po_filtrze / ile_medali * 100, 2), '% medali zdobyło górne 25 państw.' )

Ilość wierszy z medalami:  32882 ,  82.65 % medali zdobyło górne 25 państw.

# ograniczenie tylko do top 25 państw
d2 <- d1[d1$NOC %in% top_countries, ]
d2 <- d2[!is.na(only_medals$Medal), ]

# zgrupowanie
medal_yearly_counts <- d2 %>%
  group_by(NOC, Year, Season, Medal) %>%
  summarise(Count = n()) %>%
  ungroup()

`summarise()` has grouped output by 'NOC', 'Year', 'Season'. You can override using the `.groups` argument.

head(medal_yearly_counts)

# A tibble: 6 × 5
  NOC    Year Season Medal  Count
  <chr> <int> <chr>  <chr>  <int>
1 AUS    1896 Summer Bronze     1
2 AUS    1896 Summer Gold       2
3 AUS    1896 Summer <NA>       2
4 AUS    1900 Summer Bronze     3
5 AUS    1900 Summer Gold       3
6 AUS    1904 Summer Bronze     1

Poniżej zostaną uwzględnienione 0.

expand.grid tworzy kartezjańską matrycę wszystkich możliwych kombinacji

Ze względu na przesunięcie olimpiady zimowej, trzeba było specjalnie zapisać lata.

combinations_grid_summer <- expand.grid( 
  NOC = unique(d2$NOC),
  Year = seq(1896, 2016, by = 4),
  Season = c("Summer"),
  Medal = c("Gold", "Silver", "Bronze")
)

combinations_grid_winter <- expand.grid( 
  NOC = unique(d2$NOC),
  Year = c(seq(1924, 1992, by = 4), seq(1994, 2014, by = 4)), # przesunięcie odstępu w 1992 - 1994
  Season = c("Winter"),
  Medal = c("Gold", "Silver", "Bronze")
)

head(combinations_grid_winter)

  NOC Year Season Medal
1 CHN 1924 Winter  Gold
2 DEN 1924 Winter  Gold
3 NED 1924 Winter  Gold
4 USA 1924 Winter  Gold
5 FIN 1924 Winter  Gold
6 NOR 1924 Winter  Gold

Teraz łączymy obie ramki danych. Bez podziału na Winter i Summer, replace_na(list(Count = 0)) spowodowałoby, że wykresy byłyby bardzo nieczytelne od lat 80 - linia skakałaby co 2 lata do 0.

combinations_grid <- bind_rows(combinations_grid_summer, combinations_grid_winter) # pionowe złączenie

complete_medal_counts <- combinations_grid %>%
  left_join(medal_yearly_counts, by = c("NOC", "Year", "Season", "Medal")) %>%
  replace_na(list(Count = 0))

head(complete_medal_counts)

  NOC Year Season Medal Count
1 CHN 1896 Summer  Gold     0
2 DEN 1896 Summer  Gold     1
3 NED 1896 Summer  Gold     0
4 USA 1896 Summer  Gold    11
5 FIN 1896 Summer  Gold     0
6 NOR 1896 Summer  Gold     0

Poniżej kod dla utworzenia aplikacji Shiny.

### ============= UI ============= ### 
ui <- fluidPage(
  #Header
  h1("Liczba medalistów z danego kraju na przestrzeni lat"),
  fluidRow(
    column(6,
           selectInput(
             inputId = "NOC",
             label = "Wybierz kraj",
             choices = sort(unique(complete_medal_counts$NOC)),
             selected = "USA"
           )
    ),
    column(6,
           radioButtons(
             inputId = "Season",
             label = "Wybierz sezon",
             choices = unique(complete_medal_counts$Season),
             selected = "Summer"
           )
    )
  ),
  div(class = "plot-container",
      plotOutput("plot")
  )
)

### ============= SERVER ============= ### 
server <- function(input, output, session) {
  output$plot <- renderPlot({
    
    years <- if (input$Season == "Summer") c(1896, 2016) 
    else c(1924, 2014)
    ticks <- if (input$Season == "Summer") seq(1896, 2016, by = 4) 
    else c(seq(1924, 1992, by = 4), seq(1994, 2014, by = 4))
    
    complete_medal_counts %>%
      filter(NOC == input$NOC, Season == input$Season) %>%
      ggplot(aes(x=Year, y=Count, color=Medal)) +
      theme_minimal() + theme_light() +
      geom_line(size=0.8) +
      theme(text = element_text(family = "Courier New")) +
      labs(color = "Medal:", y = "Ilość medali", x = "Rok", title = "") +
      theme(
        axis.title.x = element_text(size=m, margin = margin(t = 20)),
        axis.title.y = element_text(size=m),
        axis.text.x = element_text(size=s),
        axis.text.y = element_text(size=s),
        legend.title = element_text(size=s),
        legend.text = element_text(size=s),
        legend.justification = c(0,0.5),
        plot.title = element_text(colour="Black", size=l, family="Courier New")) +
      scale_x_continuous(limits = years, breaks = ticks, minor_breaks=NULL) +
      scale_color_manual(values=medale_kolor, labels=medale_nazwy)
  })
}

shinyApp(ui, server)

Link do aplikacji

Na wykresach wyraźnie widoczne są bojkoty z olimpiady w Moskwie z 1980 roku i olimpiady w Los Angeles z 1984.

Widać również w jakich latach dane kraje istniały np. RUS, USR czy GRD, czyli Rosja, Związek Radziecki i NRD. Widoczne również są lata kiedy olimpiady nie odbywały się: 1940-1944.

## Podsumowanie

W niniejszym projekcie sprawdzono:

• wymiar danych, ogólną statystykę danych, ilość brakujących danych, dane unikalne i ich częstość
• korelacje, a właściwie w których dziedzinach sportu cechy takie jak wiek, waga i wzrost okazały się najistotniejsze / ich zróżnicowanie wśród zawodników było największe
• zwizualizowano dane w formie kilku wykresów
• utworzono interaktywną aplikację przy pomocy pakietu Shiny do pozwalająca na sprawdzenie historycznych danych najlepszych państw